TestDrive Windows 1993 Fall/TestDrive Windows 1993 Fall.iso/dbase/samples/orders.prg

Text File | 1993-03-09 | 11.4 KB | 325 lines

******************************************************************************
* PROGRAM NAME: ORDERS.PRG
*               ORDERS TRANSACTIONS DATABASE SCREEN
*               SAMPLE BUSINESS APPLICATION PROGRAM
* LAST CHANGED: 09/25/89 09:26AM
* WRITTEN BY:   Borland International Inc.
******************************************************************************
*
*       FILES USED IN CUSTOMER FILE:
*       Database    =  Orders.dbf
*       Index file  =  Orders.mdx
*        TAG: Order =  cust_id+DTOC(date_trans)+po_number <= Master index
*       External Procedure File used: Library.prg
******************************************************************************

* Main procedure
PROCEDURE Orders

   * Link to external procedure file of 'tool' procedures
   SET PROCEDURE TO Library

   * Set database environment
   DO Set_env
   SET NEAR on
   SET COLOR TO &c_standard.

   * Declare Variables Used:
   * Database memory variables
   STORE "" TO cust_id, po_number, emp_id, part_id
   STORE {  /  /  } TO date_trans
   part_qty = 0
   invoiced = .F.

   * Misc variables - used to pass parameters to Library
   * for Find record, Output reports, List records and other options
   dbf   = "ORDERS"                   && std report is available
   mlist = "NOT AVAILABLE"            && no mailing list is available
   STORE "N/A" TO cust_rpt            && no custom reports are available
   key  = "m->cust_id+DTOC(m->date_trans)+m->po_number"
   key1 = "m->cust_id"
   key2 = "m->date_trans"
   key3 = "m->po_number"
   keyname1 = "Cust ID:"
   keyname2 = "Date of Order:"
   keyname3 = "P.O. Number:"
   list_flds = "CUST_ID,DATE_TRANS,PO_NUMBER,PART_ID,PART_QTY,Goods->PRICE"
   STORE "" TO mcustid, mpartid, mempid

   gl_Error = .F.
   DO OrdersM

   RELEASE gl_MainMenu                  && Allow Rest_env to reset the
   DO Rest_env                          && environment back.
   ON ERROR
   ON KEY LABEL F1
   CLEAR ALL
   CLOSE ALL
   CLEAR

RETURN

PROCEDURE OrdersM
   * Open databases and choose active indexes
   SELECT 1
   USE Orders   ORDER Order
   USE Goods    ORDER Part_id IN 2
   USE Cust     ORDER Cust_id IN 3
   USE Employee ORDER Emp_id  IN 4
   SET RELATION TO part_id INTO Goods, cust_id INTO Cust, emp_id INTO Employee
   GO TOP

   record_num = RECNO()
   DO Load_fld

   * Show data screen
   CLEAR
   DO Dstatus
   DO Backgrnd
   DO Show_data

   * Define popup bar menus of user choices
   DO Bar_def

   * Activate main popup bar menu - execute user choices
   SET COLOR TO &c_popup.
   ACTIVATE POPUP main_mnu
   DO Sub_ret
   *
RETURN
*==============================end of main procedure==========================

*  UTILITY PROCEDURES (PROPRIETARY TO Orders)

PROCEDURE Filter
   * Filter (group) data into subset
   * Select subset to set up filter condition  (Y=turn on, N=abort selection,
   * T=turn off). If filter is already on, set default choice to Turn off,
   * show window. If filter is not on, set default choice to Yes; show window.
   choice = IIF(filters_on,"T","Y")
   DO Filt_ans
   IF choice = "Y"
      * Start process of choosing filter condition.
      *
      mcustid    = SPACE(6)
      mpartid    = SPACE(10)
      mempid     = SPACE(11)
      ACTIVATE WINDOW alert
         * Get user's filter condition selection(s)
         @  0, 0 SAY "-------- ENTER FILTER CONDITION -------"
         @  2, 0 SAY "CUST.I.D.:"     GET mcustid     FUNCTION "!" ;
            MESSAGE "Enter a six digit customer ID beginning with a " + ;
                    " letter - Esc to quit"
         @  3, 0 SAY "PART I.D.:"     GET mpartid     FUNCTION "!"
         @  4, 0 SAY "EMPLOYEE I.D.:" GET mempid
         @  5, 0 SAY "Enter one or more conditions"
         READ
     DEACTIVATE WINDOW alert
     * Initialize filter condition variable to null (empty)
     subset = " "
     * Process user's entries to build filter condition
     mcustid   = TRIM(mcustid)
     mpartid   = TRIM(mpartid)
     mempid    = TRIM(mempid)
     subset =  subset + IIF("" <> mcustid,"cust_id = '&mcustid.' .AND. ","")
     subset =  subset + IIF("" <> mpartid,"part_id = '&mpartid.' .AND. ","")
     subset =  subset + IIF("" <> mempid, "emp_id = '&mempid.'  .AND. ","")
     *
     IF "" = TRIM(subset)     && Check whether data entered into subset string
        * If nothing entered, exit
        DO Warnbell
        filters_on = .F.
     ELSE
        * If string is not empty, truncate the .AND. from end of subset string
        subset = SUBSTR(subset,1,LEN(subset)-6)
        SET FILTER TO &subset.   && Filter on entered filter string condition
        GO TOP                   && Activate filter by moving record pointer
        * Check whether filter condition matches any records (no match=EOF)
        filters_on = .NOT. EOF()
        IF .NOT. filters_on           && Filter is off if filters_on = .F.
           DO Warnbell
           DO Show_msg WITH "No Orders records match the Filter condition."
           SET FILTER TO
           GO record_num
        ENDIF
      ENDIF
   ELSE
      IF choice = "T"
         * If user selects "T", turn off filter
         SET FILTER TO
         filters_on = .F.
      ENDIF
   ENDIF
RETURN

PROCEDURE Indexer
   * Create/rebuild index
   INDEX ON cust_id+DTOC(date_trans)+po_number TAG Order
   GO TOP
RETURN

PROCEDURE Init_fld
   * Initialize memory variables values for data entry
   cust_id    = SPACE(6)
   date_trans = DATE()
   po_number  = SPACE(5)
   emp_id     = SPACE(11)
   part_id    = SPACE(10)
   part_qty   = 0
   invoiced   = .F.
RETURN

PROCEDURE Load_fld
   * Copy fields from ORDERS database record into memory variables
   cust_id    = cust_id
   date_trans = date_trans
   po_number  = po_number
   emp_id     = emp_id
   part_id    = part_id
   part_qty   = part_qty
   invoiced   = invoiced
RETURN

PROCEDURE Repl_fld
   * Replace database file fields with contents of memory variables
   REPLACE cust_id WITH m->cust_id, po_number WITH m->po_number,;
           date_trans WITH m->date_trans, emp_id WITH m->emp_id, ;
           part_id WITH m->part_id, part_qty WITH m->part_qty, ;
           invoiced  WITH m->invoiced
RETURN

FUNCTION Prof_mgn
   PARAMETERS cost,price
   * Calculate profit margin
   margin = ROUND((price-cost)/price*100,1)
RETURN margin

PROCEDURE Backgrnd
   * Show background screen
   @  1,18 TO  3,49 DOUBLE COLOR &c_blue.
   @  5, 2 TO  8,56 DOUBLE COLOR &c_red.
   @ 16, 2 TO 16,56        COLOR &c_red.
   @  9, 2 TO 18,56        COLOR &c_red.
   @  2,19 FILL TO  2,48   COLOR &c_blue.
   @  6, 3 FILL TO  7,55   COLOR &c_red.
   @ 10, 3 FILL TO 17,55   COLOR &c_red.
   @  6, 3 FILL TO 17,55   COLOR &c_red.
   SET COLOR TO &c_data.
   @  2,20 SAY "ORDERS TRANSACTIONS DATABASE"
   @  6, 4 SAY "CUSTOMER ID:"
   @  7, 4 SAY "ORDER DATE:"
   @  7,35 SAY "P.O. NUMBER:"
   @ 10, 4 SAY "PART #:"
   @ 11, 4 SAY "PART NAME:"
   @ 12, 4 SAY "QTY. ORDERED:"
   @ 12,25 SAY "each"
   @ 12,35 SAY "PRICE: $"
   @ 13, 4 SAY "QTY. AVAILABLE:"
   @ 13,25 SAY "each"
   @ 13,35 SAY "MARGIN:"
   @ 13,53 SAY "%"
   @ 14, 4 SAY "EMPLOYEE #:"
   @ 15, 4 SAY "INVOICED:"
   @ 17, 4 SAY "NOTES:"
   SET COLOR TO &c_standard.
RETURN

PROCEDURE Show_data
   * Show data screen
   SET COLOR TO &c_fields.
   @  6,18 SAY cust_id
   @  7,18 SAY date_trans
   @  7,48 SAY po_number
   @ 10,18 SAY part_id
   @ 12,21 SAY part_qty   PICTURE "999"
   @ 14,16 SAY emp_id
   @ 15,14 SAY invoiced  PICTURE  "Y"
   @ 17,14 SAY Notes
   IF .NOT. BAR() = 2           && not Add mode
      @  6,26 SAY Cust->Customer                        COLOR &c_yelowhit.
      @ 11,18 SAY Goods->Part_name                      COLOR &c_yelowhit.
      @ 12,44 SAY Goods->Price      PICTURE "99,999.99" COLOR &c_yelowhit.
      @ 13,21 SAY Goods->Qty_onhand PICTURE "999"       COLOR &c_yelowhit.
      @ 13,48 SAY Prof_mgn(Goods->Cost,Goods->Price) ;
              PICTURE "99.9" COLOR &c_yelowhit.
      @ 14,30 SAY TRIM(Employee->Firstname)+" "+ Employee->Lastname ;
              COLOR &c_yelowhit.
   ELSE
      * Mode is Add: clear screen field areas of related data
      @  6,26 SAY SPACE(30)    && CUSTOMER
      @ 11,18 SAY SPACE(20)    && PARTNAME
      @ 12,44 SAY SPACE(9)     && PRICE
      @ 13,21 SAY SPACE(3)     && QTY ONHAND
      @ 13,48 SAY SPACE(4)     && MARGIN
      @ 14,30 SAY SPACE(26)    && EMPLOYEE
   ENDIF
   IF ISCOLOR()
      @ 20, 4 SAY "Yellow text/numbers - from related databases or calc." ;
         COLOR &c_yelowhit.
   ELSE
      @ 20, 4 SAY "Dim text/numbers - from related databases or calc." ;
         COLOR &c_red.
   ENDIF
   SET COLOR TO &c_standard.
RETURN

PROCEDURE Get_data
   * Show screen for data entry
   SET COLOR TO &c_data.
   @  6,18 GET m->cust_id    PICTURE  "!99999" ;
           VALID Lookupid(m->cust_id,"Cust","Customer", 2) ;
           ERROR "Invalid customer I.D. number, please re-enter." ;
           MESSAGE "Enter a six digit customer ID (beginning with a " + ;
                   "letter) - Esc to quit"
   @  7,18 GET m->date_trans FUNCTION "D" ;
           MESSAGE "Enter date of this order"
   @  7,48 GET m->po_number  FUNCTION "!" ;
           MESSAGE "Enter customer's P.O. number"
   @ 10,18 GET m->part_id    FUNCTION "!" ;
           VALID Lookupid(m->part_id,"Goods", "Part", 3) ;
           ERROR "Invalid part ID number, please re-enter." ;
           MESSAGE "Enter a part ID number, or Esc to quit"
   @ 12,21 GET m->part_qty   PICTURE "999" ;
           MESSAGE "Enter quantity of parts ordered"
   @ 14,16 GET m->emp_id PICTURE "999-99-9999" ;
           VALID Lookupid(m->emp_id, "Employee", "Employee", 6) ;
           ERROR "Invalid employee ID number, please re-enter." ;
           MESSAGE "Enter an employee ID number, or Esc to quit"
   @ 15,14 GET m->invoiced  PICTURE  "Y" ;
           MESSAGE "Enter whether this order has been invoiced " + ;
                   "(usually done by system)"
   @ 17,14 GET Notes WINDOW memo_windo ;
           MESSAGE "Enter notes into memo field, press " + ;
                   "Ctrl-Home to enter (Ctrl-End to exit)"
   IF .NOT. BAR() = 2           && not Add mode
      @  6,26 SAY Cust->Customer                        COLOR &c_yelowhit.
      @ 11,18 SAY Goods->Part_name                      COLOR &c_yelowhit.
      @ 12,44 SAY Goods->Price      PICTURE "99,999.99" COLOR &c_yelowhit.
      @ 13,21 SAY Goods->Qty_onhand PICTURE "999"       COLOR &c_yelowhit.
      @ 13,48 SAY Prof_mgn(Goods->Cost,Goods->Price) ;
              PICTURE "99.9" COLOR &c_yelowhit.
      @ 14,30 SAY TRIM(Employee->Firstname)+" "+ Employee->Lastname ;
              COLOR &c_yelowhit.
   ELSE
      * Mode is Add: clear screen field areas of related data
      @  6,26 SAY SPACE(30)    && CUSTOMER
      @ 11,18 SAY SPACE(20)    && PARTNAME
      @ 12,44 SAY SPACE(9)     && PRICE
      @ 13,21 SAY SPACE(3)     && QTY ONHAND
      @ 13,48 SAY SPACE(4)     && MARGIN
      @ 14,30 SAY SPACE(26)    && EMPLOYEE
   ENDIF
   IF ISCOLOR()
      @ 20, 4 SAY "Yellow text/numbers - from related databases or calc." ;
         COLOR &c_yelowhit.
   ELSE
      @ 20, 4 SAY "Dim text/numbers - from related databases or calc." ;
         COLOR &c_red.
   ENDIF
   SET COLOR TO &c_standard.
   ON KEY LABEL F9 DO Findcust WITH m->cust_id
   ON KEY LABEL F10 DO Findpart WITH m->part_id
RETURN
************************************** END OF ORDERS.PRG *********************